home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 2 / Apprentice-Release2.iso / Tools / Languages / Mops 2.5 / Mops ƒ / Modules < prev    next >
Encoding:
Text File  |  1994-08-30  |  12.3 KB  |  514 lines  |  [TEXT/MSET]
  1. \ This file implements relocatable modules.  In installed applications,
  2. \ these become separate code segments.
  3.  
  4. true    value    CLEANMOD?
  5. false    value    RELEASED?
  6.     0    value    THIS_MOD
  7.     0    value    LAST_MOD
  8.     0    value    SVDP
  9.     0    value    SVLATEST
  10.     0    value    MODSTART
  11.  
  12.     string    $EXP
  13.     string    $CXT
  14.  
  15. \ variable    SAVE_CONTEXT    8 4 *  allot
  16.  
  17. : UNMOD        \ Puts things back to normal after a module
  18.             \ or stand-alone code compilation
  19.     svDP  0EXIT        \ Out if we're not compiling a module/SA
  20.     svLatest -> latest
  21.     svDP -> DP  0 -> svDP  0 -> compMod
  22.     nil?: $cxt  NIF  ptr: $cxt  context  32  cmove  release: $cxt  THEN
  23.     false -> SAcomp?  ;
  24.  
  25. : >NXTEXP    \ ( n -- )
  26.     modstart -  pad !  pad 4  add: $exp  ;
  27.  
  28.  
  29. :class    MODULE    super{ object }
  30.  
  31. record
  32. {    handle    MODHDL
  33.     byte    EXEC_CNT        \ Must be at an even offset since we sometimes
  34.     bool    LOCKED?            \  do a combined access to exec_cnt and locked? !
  35.     byte    FLAGS
  36.     int        RES#
  37.     int        #IMP
  38.     dicaddr    LASTIMP
  39.     dicaddr    LOADPOINT
  40.     var        DicDateTime
  41.     int        RELOFFS
  42.     int        INSTALL?
  43. }
  44.  
  45. :m BASE:
  46.     nil?: modHdl  IF  0  EXIT  THEN
  47.     nptr: modHdl  ;m
  48.  
  49. :m HANDLE:    get: modHdl  ;m
  50.  
  51. :m .ID:        ^base obj>  .id  ;m
  52.  
  53. :m SETRELEASE:    \ ( addr -- )
  54.     modbase -  put: relOffs  ;m
  55.  
  56. :m SETRESID:    \ ( resID -- )
  57.     put: res#  ;m
  58.  
  59. :m INSTALL?:    get: install?  ;m
  60. :m SETINSTALL:    put: install?  ;m
  61.  
  62.  
  63. \ KLUDGE: and UNKLUDGE: may be used when we save a dic image, to mark
  64. \ a module as unloaded in the saved image without really unloading it.
  65.  
  66. :m KLUDGE:    \ ( -- modHdl flags exec+locked? )
  67.     get: modHdl  get: flags  addr: exec_cnt  w@  nilH  put: modHdl  ;m
  68.  
  69. :m UNKLUDGE:    \ ( modHdl flags exec+locked? -- )
  70.     addr: exec_cnt  w!  put: flags  put: modHdl  ;m
  71.  
  72. :m GETNAME:    \ ( -- addr len )
  73.     ^base  obj> >name n>count  ;m
  74.  
  75. :m EXTNAME:  { xaddr xlen \ len -- addr' len' }
  76.     getName: self  -> len   pad len cmove
  77.     xaddr  pad len +  xlen  cmove        \ Add extension
  78.     pad  len xlen +  ;m
  79.  
  80. :m BINNAME:    \ ( -- addr len )  Leaves name of binary file for module.
  81.     " .BIN" extName: self  ;m
  82.  
  83. :m TXTNAME:    \ ( -- addr len )  Leaves name of text file for module.
  84.     " .TXT" extName: self  ;m
  85.  
  86.  
  87. :m LOAD:  { \ rc -- }        \ Loads if not loaded already
  88.     nil?: modHdl  0EXIT
  89.     get: res#
  90.     IF    'type CODE  get: res#  getRes  dup 0= ?error 138
  91.         put: modHdl
  92.     ELSE
  93.         binName: self  name: fFcb  0 setVref: fFcb
  94.         openReadOnly: fFcb  ?error 138
  95.         ['] pause 4+ @  0 -> pause        \ Disable pause over read to avoid
  96.                                         \  possible reentrancy
  97.         size: fFcb  dup  new: modHdl
  98.         lock: modHdl                    \ Maybe we need this
  99.         ptr: modHdl  swap  read: fFcb  -> rc
  100.         ['] pause 4+ !                    \ Restore pause
  101.         unlock: modHdl                    \ Unlock before error check
  102.         close: fFcb  drop  rc ?error 141
  103.         base: self @  get: dicDateTime  u<
  104.         IF                                \ BIN file is old version
  105.             release: modHdl  148 die
  106.         THEN
  107.     THEN
  108.     moveHi: modHdl                        \ Move module hi since it gets locked
  109.     clear: exec_cnt  ;m
  110.  
  111.  
  112. :m RELEASE:  { \ svModbase -- }
  113.     clear: exec_cnt                    \ We certainly hope we know what we're
  114.     clear: locked?                    \  doing!!
  115.     get: modHdl  nilH =  ?EXIT        \ Out if not loaded
  116.     get: relOffs  -1 <>                \ Any module-specific action?
  117.     IF                                \ Yes
  118.         lock: modHdl                \ We're going to execute in the module
  119.         modbase -> svModbase
  120.         ptr: modHdl  32766 +  dup  -> modbase
  121.         get: relOffs +
  122.         execute                        \ Execute the appropriate word
  123.         svModbase -> modbase        \ No need to unlock since we're
  124.                                     \  just about to release
  125.     THEN
  126.     get: res#                          \ Resource?
  127.     IF
  128.         get: modHdl  trap$ a9a3        \ call ReleaseResource
  129.         nilH put: modHdl
  130.     ELSE
  131.         release: modHdl
  132.     THEN
  133.     true -> released?  ;m
  134.  
  135. (*
  136. KEEP: and DROP: flag this module as needed and not needed, respectively.
  137. The main purpose of this flagging is that if GETSPACE is called, loaded
  138. modules will be released to make room, unless they have been flagged as
  139. needed by KEEP:.  But note that RELEASE: ignores the flag, so that we
  140. can get rid of a module by force if necessary.  This may happen if there
  141. was a crash while the module was executing.
  142.  
  143. LOCK: is more drastic than KEEP:, since it means that this module becomes
  144. non-relocatable.  UNLOCK: reverses a LOCK:.  Note that DROP: in effect does
  145. an UNLOCK: as well.
  146.  
  147. This "locking" feature is used for ExtrasMod, which has a window, and
  148. for the debugger and printMod, which can be entered through the back
  149. door (via a vect or a trap).  (By the way, we hope we won't have to do this
  150. back door business anywhere else.  Entering a module through the back door
  151. is not usually a very safe thing to do.)
  152.  
  153. Locking a module can give a useful performance improvement if a module is to
  154. be called several times in succession, since we bypass the _HLock and _Hunlock
  155. calls if the module is marked locked.
  156. *)
  157.  
  158. :m KEEP:
  159.     addr: flags 1 bset  ;m
  160.  
  161. :m DROP:
  162.     get: exec_cnt NIF  unlock: modHdl  THEN  \ Unlock if not executing
  163.     addr: flags 1 breset  clear: locked?  ;m
  164.  
  165. :m LOCK:
  166.     true  put: locked?  load: self  lock: modHdl  ;m
  167.         \ Note: loading does a MoveHi so we don't need to do it again.
  168.  
  169. :m UNLOCK:
  170.     false  put: locked?
  171.     get: exec_cnt NIF  nil?: modHdl NIF  unlock: modHdl  THEN THEN  ;m
  172.  
  173. :m KEEP?:
  174.     get: exec_cnt  0<>  get: flags  or  ;m
  175.  
  176. :m LOCKED?:
  177.     get: exec_cnt  get: locked?  or  ;m
  178.  
  179.  
  180. :m ?RELEASE:
  181.     keep?: self  ?EXIT
  182.     release: self  ;m
  183.  
  184. :m #IMP:    get: #imp  ;m
  185.  
  186. :m GETIMPORTS:  { \ n -- }
  187.     0 -> n
  188.     BEGIN
  189.         header  -92 w,        \ Header with handler code for imported word
  190.         ^base compimp  1 ++> n
  191.         & }  endlist?
  192.     UNTIL
  193.     n 1-  put: #imp
  194.     latest  name>  put: lastimp
  195.     here  put: loadpoint  ;m
  196.  
  197.  
  198. \                ===================================
  199. \                        Module compilation
  200. \                ===================================
  201.  
  202. private
  203.  
  204. :m ExpSupers:  { ^nw -- }
  205.     BEGIN
  206.         ^nw @ 0EXIT
  207.         ^nw relocType  InThisMod =
  208.         IF  ^nw @abs mfa displace  expMethods: [self]  THEN
  209.         4 ++> ^nw
  210.     AGAIN  ;m
  211.  
  212. public
  213.                 \ This gets called via a late bind, so must be public
  214. :m ExpMethods:  { maddr -- }
  215.     BEGIN                \ Loop thru methods in this class
  216.         maddr @ 0>=
  217.         IF            \ We've come to the superclasses
  218.             maddr  expSupers: self  EXIT
  219.         THEN
  220.                     \ Next method
  221.         maddr 10 +  >nxtExp
  222.         maddr 4+ displace  -> maddr
  223.     AGAIN  ;m
  224.  
  225. private
  226.  
  227.  
  228. mlocal !exports: { \ thisImp thisCfa maddr -- }
  229.  
  230. :m ?!class:    \ If this exported item is a class, we set the handler
  231.             \ code of the imported version and add the method entry offsets
  232.             \ to the export table.
  233.  
  234.     thisCfa 2- w@x -58 =  0EXIT        \ Out if it isn't a class
  235.     -90  thisImp 2- w!
  236.     thisCfa ffa 1+ 1 bset
  237.     thisCfa mfa  displace  expMethods: self  ;m
  238.  
  239.  
  240. :m 1export:
  241.     next: theMark  link> -> thisImp
  242.     thisImp  >name n>count  sFind
  243.     drop -> thisCfa
  244.     thisCfa thisImp =
  245.     IF                                        \ Not defined
  246.         cr thisImp .id  2 spaces  144 die
  247.                                     \ "You forgot to define this exported name"
  248.         false -> cleanMod?
  249.     ELSE                            \ All OK. Put info into import definition:
  250.         thisCfa >name c@  thisImp >name c!    \ Name flags
  251.         pos: $exp  thisImp 4+ w!            \ Export table index
  252.         thisCfa >nxtExp                        \ Add next exp tbl entry
  253.         ?!class: self                        \ More stuff if it's a class
  254.     THEN  ;m
  255.  
  256.  
  257. :mloc !exports:        \ { \ n thisImp thisCfa maddr -- }
  258.     get: #imp  0= ?error 143            \ Module has no exported names
  259.     clear: $exp
  260.     get: lastimp  set: theMark
  261.     get: #imp  FOR  1export: self  NEXT
  262. ;mloc
  263.  
  264.  
  265. (*
  266. FixLinks: fixes up the dictionary links within the compiled module.  We may
  267. want to find words in the module at run time via FIND, but the problem is that
  268. dic links are relative, not relocatable.  This makes FIND fast, but leads
  269. to a problem at run time when the the module is disconnected from the main
  270. dictionary.  If we didn't do anything, we wouldn't know where to start
  271. searching from, and if the search failed, the last link would point into
  272. outer space.
  273. So what we do is to add a snapshot of CONTEXT to the end of the module to give
  274. a place to start from, and to clear the lowest link on each thread to zero (which
  275. means the end).
  276. *)
  277.  
  278. :m FixLinks:  { \ link prevLink -- }
  279.     #threads FOR
  280.         context  i cells +  -> link
  281.         BEGIN
  282.             link -> prevLink
  283.             link displace -> link
  284.             link modstart u<
  285.         UNTIL
  286.         0 prevLink !
  287.     NEXT
  288.     here 4+ context -  ,            \ Adjustment value for context copy
  289.     context 32  n,                    \ Add copy of Context to end of module
  290. ;m
  291.  
  292. :m GoodCompile:  { \ size -- }
  293.     here  modstart 8 +  displ!        \ Store export table offs in header
  294.     all: $exp  n,                    \ Add export table to end
  295.     fixLinks: self                    \ fix dic links in module
  296.     here modstart -  -> size        \ Size of module
  297.     size  modstart 12 +  !            \ Store size in header
  298.     binName: self  name: fFcb        \ Set name of binary file
  299.     create: fFcb  ?error 139
  300.     'type BIN  'type MOPS  set: fFcb    \ Type and signature
  301.     modstart  size  write: fFcb            \ Write out binary module
  302.     close: fFcb  drop
  303.     IF    msg# 140                    \ I/O error on writing bin file
  304.     ELSE
  305.         curs  -curs
  306.         cr  getName: fFcb type  ."  saved" cr
  307.         -> curs
  308.     THEN
  309. ;m
  310.  
  311. public
  312.  
  313. :m COMPILE:  { \ newModbase -- }
  314.     compMod  ?error 177                    \ Error if already compiling a module
  315.     release: self                        \ Get rid of old version, if loaded
  316.     context 32  put: $cxt                \ save CONTEXT since we're going
  317.                                         \ to do a temporary FORGET
  318.     dp -> svDP  latest -> svLatest  ^base -> compMod
  319.     get: loadpoint  (forget)  svDP -> dp
  320.     true -> cleanMod?
  321.     pushNew: loadFile
  322.     txtName: self  name: topFile
  323.     here -> modstart
  324.     modstart 32766 +  -> newModbase
  325.     16  reserve            \ Reserve space for header and offset to exports table.
  326.     ^base -> this_mod
  327.     newModbase LdFromMod
  328.     dateTime  modstart !                \ Put source date in bin module header
  329.     getDirID: topFile  modstart 4+ !    \ Also DirID of source file
  330.     drop: loadfile
  331.     0 -> this_mod
  332.     !exports: self
  333.     cleanMod?
  334.     IF    goodCompile: self            \ Everything's OK.  Do final housekeeping
  335.     THEN
  336.     unmod                            \ Also releases $cxt
  337.     release: $exp  ;m
  338.  
  339.  
  340. :m FIND: { s255 \ thrdOffs modCxt cxtOffs -- cfa T | -- s255 F }
  341.     load: self
  342.     s255                                    \ leave on stack for (find)
  343.     dup c@ 7 and 4*  -> thrdOffs            \ like what THREAD does
  344.     nptr: modHdl  size: modHdl +  32 -  -> modCxt
  345.     modCxt 4- @  -> cxtOffs
  346.     modCxt thrdOffs +  displace
  347.     dup NIF            \ thread is empty
  348.         drop false  EXIT
  349.     THEN
  350.     cxtOffs -
  351.     ( s255 1st-link )  (find)
  352. ;m
  353.  
  354. :m CLASSINIT:
  355.     -1  put: relOffs
  356.     dateTime put: dicDateTime  ;m
  357.  
  358. ;class
  359.  
  360.  
  361. : SETRELEASE    \ ( addr -- )
  362.     setRelease: this_mod  ;
  363.  
  364. : MLD
  365.     dup  load: **  ;
  366.  
  367. ' mld -> modLoad
  368.  
  369. : MOD?        \ ( cfa -- cfa b )
  370.     objCfa?  NIF  false  EXIT  THEN
  371.     dup >obj >classCfa  ['] module  =  ;
  372.  
  373.  
  374. : ?DISP  { theCfa size -- }        \ handler to release selected modules
  375.     theCfa mod?  NIF  drop  EXIT  THEN
  376.     free size <            \ Do we still need space?
  377.     IF    >obj  ?release: module
  378.     ELSE    drop
  379.     THEN  ;
  380.  
  381.  
  382. \ PURGE forcibly releases all modules, no matter what.  It is a vector,
  383. \ defined in file Base.
  384.  
  385. : (PRG)  { theCfa size -- }    \ unlock and release
  386.     theCfa mod? NIF  drop  EXIT  THEN
  387.     >obj release: module  ;
  388.  
  389. : (PURGE)    ['] (prg)  big#  trav  ;
  390.  
  391. ' (purge) -> purge
  392.  
  393.  
  394. : NEEDSPACE    \ ( #bytes -- ) release modules until #bytes are available
  395.     false -> released?
  396.     freeblk drop  ['] ?disp swap trav  ;
  397.  
  398. : GS    big# needSpace  released?  ;
  399.  
  400. ' gs -> getSpace
  401.  
  402.  
  403. : FROM        \ ( -- ^mod sec# )
  404.     module                            \ Create module object
  405.     latest name> >obj  dup -> last_mod  28  ;
  406.  
  407.  
  408. : IMPORT{    \ ( ^mod sec# -- )
  409.     28 ?pairs  getImports: **  ;
  410.  
  411. : EXPORTS_CLASS
  412.     last_mod  exports_class: **  ;
  413.  
  414.  
  415. (* ******
  416. \ Testing:
  417.  
  418. : QQ    ." The right QQ!" cr  ;
  419.  
  420. from TESTMOD  import{ AA BB CC }
  421.  
  422. : QQ    ." This is the wrong QQ!!!"  ;        \ This one shouldn't!
  423.  
  424. compile: testmod
  425.  
  426. : LOOKFOR    Mword  find: testmod  ;
  427.  
  428. ****** *)
  429.  
  430.  
  431. \ Now that's done, the next thing we need to do is set up our HFS file
  432. \ access:
  433.  
  434. from PATHSMOD    import{  OWP  GETPATHS  .PATHS  }
  435.  
  436. :f OPEN_WITH_PATHS    OWP  ;f
  437.  
  438. compile: pathsMod
  439.  
  440. true -> use_paths?
  441. " mops.paths"  getPaths
  442.  
  443. \ Right, we now have HFS paths, so we can access our source files in
  444. \ different folders.
  445.  
  446. from CALL1&LMOD    import{  CallFirst  CallLast  (GET)  (C1)  (CL)  }
  447.  
  448. ' (get) -> get1st&last
  449. ' (C1)  -> doCall1st
  450. ' (CL)  -> doCallLast
  451.  
  452. compile: call1&Lmod
  453.  
  454.  
  455.  
  456. 0    value        CASE_TYPE
  457.  
  458. from CASEMOD     import{  case[ ]=> ], range]=> range], default=> ]case
  459.                             select[  ]select }
  460.  
  461. compile: caseMod
  462.  
  463. : SELECT{    postpone select[  ;        immediate
  464. : }SELECT    postpone ]select  ;        immediate
  465. : IS{        postpone ]=>      ;        immediate
  466. : }END        postpone [          ;        immediate
  467. : DEFAULT{    postpone ]  postpone default=>  postpone drop  ;    immediate
  468.  
  469.  
  470. from TOOL        import{  CALL ASMCALL FCALL GLOBAL $>GLOB KONST $>KONST  }
  471. compile: tool
  472.  
  473. from ASMMOD    import{  ASM :CODE :MCODE TOCODE  }
  474. compile: asmmod
  475.  
  476. endload
  477.  
  478.  
  479.  
  480.  
  481. \ More testing stuff:
  482.  
  483. +echo
  484.  
  485. :class    HAHA    super{ int }
  486.  
  487. callLast    print:
  488.  
  489. :m BAtest:
  490.     1 2 3 . . .  ;m
  491. ;class
  492.  
  493. :class SUBHAHA  super{ haha }
  494.  
  495. callLast    dump:
  496.  
  497. :m BAtest:  -9 -8 -7 . . .  ;m
  498.  
  499. ;class
  500.  
  501. haha    hh
  502. subhaha    ss
  503.  
  504. : q db batest: hh  batest: ss  ;
  505.  
  506. endload
  507.  
  508.  
  509. : QQ    ." QQ here.  Hello. "  ;        \ This gets called from testMod
  510.  
  511. variable VB
  512.  
  513. \ compile: testmod2
  514.